home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / Pascal / Applications / P4⁄Mac 2.0d4 / Original source & doc / pint.p < prev    next >
Encoding:
Text File  |  1996-09-24  |  27.5 KB  |  1,018 lines  |  [TEXT/ttxt]
  1. (*Assembler and interpreter of Pascal code*)
  2. (*K. Jensen, N. Wirth, Ch. Jacobi, ETH May 76*)
  3.  
  4. program pcode(input,output,prd,prr);
  5.  
  6. (* Note for the implementation.
  7.    ===========================
  8. This interpreter is written for the case where all the fundamental types
  9. take one storage unit.
  10. In an actual implementation, the handling of the sp pointer has to take
  11. into account the fact that the types may have lengths different from one:
  12. in push and pop operations the sp has to be increased and decreased not
  13. by 1, but by a number depending on the type concerned.
  14. However, where the number of units of storage has been computed by the
  15. compiler, the value must not be corrected, since the lengths of the types
  16. involved have already been taken into account.
  17.                                  *)
  18.  
  19.  
  20. label 1;
  21. const codemax     = 8650;
  22.       pcmax       = 17500;
  23.       maxstk      = 13650; (* size of variable store *)
  24.       overi       = 13655; (* size of integer constant table = 5 *)
  25.       overr       = 13660; (* size of real constant table = 5 *)
  26.       overs       = 13730; (* size of set constant table = 70 *)
  27.       overb       = 13820;
  28.       overm       = 18000;
  29.       maxstr      = 18001;
  30.       largeint    = 26144;
  31.       begincode   = 3;
  32.       inputadr    = 5;
  33.       outputadr   = 6;
  34.       prdadr      = 7;
  35.       prradr      = 8;
  36.       duminst     = 62;
  37.  
  38. type  bit4      = 0..15;
  39.       bit6      = 0..127;
  40.       bit20       = -26143..26143;
  41.       datatype    = (undef,int,reel,bool,sett,adr,mark,car);
  42.       address     = -1..maxstr;
  43.       beta      = packed array[1..25] of char; (*error message*)
  44.       settype     = set of 0..58;
  45.       alfa        = packed array[1..10] of char;
  46.  
  47. var   code      : array[0..codemax] of   (* the program *)
  48.               packed record  op1    :bit6;
  49.                      p1     :bit4;
  50.                      q1     :bit20;
  51.                      op2    :bit6;
  52.                      p2     :bit4;
  53.                      q2     :bit20
  54.                  end;
  55.       pc       : 0..pcmax;     (*program address register*)
  56.       op : bit6; p : bit4; q : bit20;  (*instruction register*)
  57.  
  58.       store       : array [0..overm] of
  59.                record case datatype of
  60.                 int    :(vi :integer);
  61.                 reel       :(vr :real);
  62.                 bool       :(vb :boolean);
  63.                 sett       :(vs :settype);
  64.                 car    :(vc :char);
  65.                 adr    :(va :address);
  66.                          (*address in store*)
  67.                 mark       :(vm :integer)
  68.             end;
  69.        mp,sp,np,ep : address;  (* address registers *)
  70.        (*mp  points to beginning of a data segment
  71.      sp  points to top of the stack
  72.      ep  points to the maximum extent of the stack
  73.      np  points to top of the dynamically allocated area*)
  74.  
  75.        interpreting: boolean;
  76.        prd,prr     : text;(*prd for read only, prr for write only *)
  77.  
  78.        instr       : array[bit6] of alfa; (* mnemonic instruction codes *)
  79.        cop     : array[bit6] of integer;
  80.        sptable     : array[0..20] of alfa; (*standard functions and procedures*)
  81.  
  82.       (*locally used for interpreting one instruction*)
  83.        ad,ad1      : address;
  84.        b       : boolean;
  85.        i,j,i1,i2   : integer;
  86.        c       : char;
  87.  
  88. (*--------------------------------------------------------------------*)
  89.  
  90. procedure load;
  91.    const maxlabel = 1850;
  92.    type  labelst  = (entered,defined); (*label situation*)
  93.      labelrg  = 0..maxlabel;       (*label range*)
  94.      labelrec = record
  95.               val: address;
  96.                st: labelst
  97.             end;
  98.    var  icp,rcp,scp,bcp,mcp  : address;  (*pointers to next free position*)
  99.     word : array[1..10] of char; i  : integer;  ch  : char;
  100.     labeltab: array[labelrg] of labelrec;
  101.     labelvalue: address;
  102.  
  103.    procedure init;
  104.       var i: integer;
  105.    begin instr[ 0]:='lod       ';       instr[ 1]:='ldo       ';
  106.      instr[ 2]:='str       ';       instr[ 3]:='sro       ';
  107.      instr[ 4]:='lda       ';       instr[ 5]:='lao       ';
  108.      instr[ 6]:='sto       ';       instr[ 7]:='ldc       ';
  109.      instr[ 8]:='...       ';       instr[ 9]:='ind       ';
  110.      instr[10]:='inc       ';       instr[11]:='mst       ';
  111.      instr[12]:='cup       ';       instr[13]:='ent       ';
  112.      instr[14]:='ret       ';       instr[15]:='csp       ';
  113.      instr[16]:='ixa       ';       instr[17]:='equ       ';
  114.      instr[18]:='neq       ';       instr[19]:='geq       ';
  115.      instr[20]:='grt       ';       instr[21]:='leq       ';
  116.      instr[22]:='les       ';       instr[23]:='ujp       ';
  117.      instr[24]:='fjp       ';       instr[25]:='xjp       ';
  118.      instr[26]:='chk       ';       instr[27]:='eof       ';
  119.      instr[28]:='adi       ';       instr[29]:='adr       ';
  120.      instr[30]:='sbi       ';       instr[31]:='sbr       ';
  121.      instr[32]:='sgs       ';       instr[33]:='flt       ';
  122.      instr[34]:='flo       ';       instr[35]:='trc       ';
  123.      instr[36]:='ngi       ';       instr[37]:='ngr       ';
  124.      instr[38]:='sqi       ';       instr[39]:='sqr       ';
  125.      instr[40]:='abi       ';       instr[41]:='abr       ';
  126.      instr[42]:='not       ';       instr[43]:='and       ';
  127.      instr[44]:='ior       ';       instr[45]:='dif       ';
  128.      instr[46]:='int       ';       instr[47]:='uni       ';
  129.      instr[48]:='inn       ';       instr[49]:='mod       ';
  130.      instr[50]:='odd       ';       instr[51]:='mpi       ';
  131.      instr[52]:='mpr       ';       instr[53]:='dvi       ';
  132.      instr[54]:='dvr       ';       instr[55]:='mov       ';
  133.      instr[56]:='lca       ';       instr[57]:='dec       ';
  134.      instr[58]:='stp       ';       instr[59]:='ord       ';
  135.      instr[60]:='chr       ';       instr[61]:='ujc       ';
  136.  
  137.      sptable[ 0]:='get       ';     sptable[ 1]:='put       ';
  138.      sptable[ 2]:='rst       ';     sptable[ 3]:='rln       ';
  139.      sptable[ 4]:='new       ';     sptable[ 5]:='wln       ';
  140.      sptable[ 6]:='wrs       ';     sptable[ 7]:='eln       ';
  141.      sptable[ 8]:='wri       ';     sptable[ 9]:='wrr       ';
  142.      sptable[10]:='wrc       ';     sptable[11]:='rdi       ';
  143.      sptable[12]:='rdr       ';     sptable[13]:='rdc       ';
  144.      sptable[14]:='sin       ';     sptable[15]:='cos       ';
  145.      sptable[16]:='exp       ';     sptable[17]:='log       ';
  146.      sptable[18]:='sqt       ';     sptable[19]:='atn       ';
  147.      sptable[20]:='sav       ';
  148.  
  149.      cop[ 0] := 105;  cop[ 1] :=  65;
  150.      cop[ 2] :=  70;  cop[ 3] :=  75;
  151.      cop[ 6] :=  80;  cop[ 9] :=  85;
  152.      cop[10] :=  90;  cop[26] :=  95;
  153.      cop[57] := 100;
  154.  
  155.      pc  := begincode;
  156.      icp := maxstk + 1;
  157.      rcp := overi + 1;
  158.      scp := overr + 1;
  159.      bcp := overs + 2;
  160.      mcp := overb + 1;
  161.      for i:= 1 to 10 do word[i]:= ' ';
  162.      for i:= 0 to maxlabel do
  163.          with labeltab[i] do begin val:=-1; st:= entered end;
  164.      reset(prd);
  165.    end;(*init*)
  166.  
  167.    procedure errorl(string: beta); (*error in loading*)
  168.    begin writeln;
  169.       write(string);
  170.       halt
  171.    end; (*errorl*)
  172.  
  173.    procedure update(x: labelrg); (*when a label definition lx is found*)
  174.       var curr,succ: -1..pcmax;  (*resp. current element and successor element
  175.                    of a list of future references*)
  176.       endlist: boolean;
  177.    begin
  178.       if labeltab[x].st=defined then errorl(' duplicated label    ')
  179.       else begin
  180.          if labeltab[x].val<>-1 then (*forward reference(s)*)
  181.          begin curr:= labeltab[x].val; endlist:= false;
  182.         while not endlist do
  183.               with code[curr div 2] do
  184.               begin
  185.              if odd(curr) then begin succ:= q2;
  186.                          q2:= labelvalue
  187.                        end
  188.                       else begin succ:= q1;
  189.                          q1:= labelvalue
  190.                        end;
  191.              if succ=-1 then endlist:= true
  192.                     else curr:= succ
  193.               end;
  194.           end;
  195.           labeltab[x].st := defined;
  196.           labeltab[x].val:= labelvalue;
  197.        end
  198.    end;(*update*)
  199.  
  200.    procedure assemble; forward;
  201.  
  202.    procedure generate;(*generate segment of code*)
  203.       var x: integer; (* label number *)
  204.       again: boolean;
  205.    begin
  206.       again := true;
  207.       while again do
  208.         begin read(prd,ch);(* first character of line*)
  209.           case ch of
  210.                'i': readln(prd);
  211.                'l': begin read(prd,x);
  212.                   if not eoln(prd) then read(prd,ch);
  213.                   if ch='=' then read(prd,labelvalue)
  214.                         else labelvalue:= pc;
  215.                   update(x); readln(prd);
  216.                 end;
  217.                'q': begin again := false; readln(prd) end;
  218.                ' ': begin read(prd,ch); assemble end
  219.           end;
  220.         end
  221.    end; (*generate*)
  222.  
  223.    procedure assemble; (*translate symbolic code into machine code and store*)
  224.       label 1;     (*goto 1 for instructions without code generation*)
  225.       var name :alfa;  b :boolean;  r :real;  s :settype;
  226.       c1 :char;  i,s1,lb,ub :integer;
  227.  
  228.       procedure lookup(x: labelrg); (* search in label table*)
  229.       begin case labeltab[x].st of
  230.         entered: begin q := labeltab[x].val;
  231.                labeltab[x].val := pc
  232.              end;
  233.         defined: q:= labeltab[x].val
  234.         end(*case label..*)
  235.       end;(*lookup*)
  236.  
  237.       procedure labelsearch;
  238.      var x: labelrg;
  239.       begin while (ch<>'l') and not eoln(prd) do read(prd,ch);
  240.         read(prd,x); lookup(x)
  241.       end;(*labelsearch*)
  242.  
  243.       procedure getname;
  244.       begin  word[1] := ch;
  245.      read(prd,word[2],word[3]);
  246.      if not eoln(prd) then read(prd,ch) (*next character*);
  247.      pack(word,1,name)
  248.       end; (*getname*)
  249.  
  250.       procedure typesymbol;
  251.     var i: integer;
  252.       begin
  253.     if ch <> 'i' then
  254.       begin
  255.         case ch of
  256.           'a': i := 0;
  257.           'r': i := 1;
  258.           's': i := 2;
  259.           'b': i := 3;
  260.           'c': i := 4;
  261.         end;
  262.         op := cop[op]+i;
  263.       end;
  264.       end (*typesymbol*) ;
  265.  
  266.    begin  p := 0;  q := 0;  op := 0;
  267.       getname;
  268.       instr[duminst] := name;
  269.       while instr[op]<>name do op := op+1;
  270.       if op = duminst then errorl(' illegal instruction     ');
  271.  
  272.       case op of  (* get parameters p,q *)
  273.  
  274.       (*equ,neq,geq,grt,leq,les*)
  275.       17,18,19,
  276.       20,21,22: begin case ch of
  277.                   'a': ; (*p = 0*)
  278.                   'i': p := 1;
  279.                   'r': p := 2;
  280.                   'b': p := 3;
  281.                   's': p := 4;
  282.                   'c': p := 6;
  283.                   'm': begin p := 5;
  284.                      read(prd,q)
  285.                    end
  286.               end
  287.             end;
  288.  
  289.       (*lod,str*)
  290.       0,2: begin typesymbol; read(prd,p,q)
  291.            end;
  292.  
  293.       4  (*lda*): read(prd,p,q);
  294.  
  295.       12 (*cup*): begin read(prd,p); labelsearch end;
  296.  
  297.       11 (*mst*): read(prd,p);
  298.  
  299.       14 (*ret*): case ch of
  300.                 'p': p:=0;
  301.                 'i': p:=1;
  302.                 'r': p:=2;
  303.                 'c': p:=3;
  304.                 'b': p:=4;
  305.                 'a': p:=5
  306.               end;
  307.  
  308.       (*lao,ixa,mov*)
  309.       5,16,55: read(prd,q);
  310.  
  311.       (*ldo,sro,ind,inc,dec*)
  312.       1,3,9,10,57: begin typesymbol; read(prd,q)
  313.                end;
  314.  
  315.       (*ujp,fjp,xjp*)
  316.       23,24,25: labelsearch;
  317.  
  318.       13 (*ent*): begin read(prd,p); labelsearch end;
  319.  
  320.       15 (*csp*): begin for i:=1 to 9 do read(prd,ch); getname;
  321.                while name<>sptable[q] do  q := q+1
  322.               end;
  323.  
  324.       7 (*ldc*): begin case ch of  (*get q*)
  325.                'i': begin  p := 1;  read(prd,i);
  326.                    if abs(i)>=largeint then
  327.                    begin  op := 8;
  328.                       store[icp].vi := i;  q := maxstk;
  329.                       repeat  q := q+1  until store[q].vi=i;
  330.                       if q=icp then
  331.                       begin  icp := icp+1;
  332.                     if icp=overi then
  333.                       errorl(' integer table overflow  ');
  334.                       end
  335.                    end  else q := i
  336.                 end;
  337.  
  338.                'r': begin  op := 8; p := 2;
  339.                    read(prd,r);
  340.                    store[rcp].vr := r;  q := overi;
  341.                    repeat  q := q+1  until store[q].vr=r;
  342.                    if q=rcp then
  343.                    begin  rcp := rcp+1;
  344.                      if rcp = overr then
  345.                        errorl(' real table overflow     ');
  346.                    end
  347.                 end;
  348.  
  349.                'n': ; (*p,q = 0*)
  350.  
  351.                'b': begin p := 3;  read(prd,q)  end;
  352.  
  353.                'c': begin p := 6;
  354.                   repeat read(prd,ch); until ch <> ' ';
  355.                   if ch <> '''' then
  356.                     errorl(' illegal character       ');
  357.                   read(prd,ch);  q := ord(ch);
  358.                   read(prd,ch);
  359.                   if ch <> '''' then
  360.                     errorl(' illegal character       ');
  361.                 end;
  362.                '(': begin  op := 8;  p := 4;
  363.                    s := [ ];  read(prd,ch);
  364.                    while ch<>')' do
  365.                    begin read(prd,s1,ch); s := s + [s1]
  366.                    end;
  367.                    store[scp].vs := s;  q := overr;
  368.                    repeat  q := q+1  until store[q].vs=s;
  369.                    if q=scp then
  370.                    begin  scp := scp+1;
  371.                       if scp=overs then
  372.                     errorl(' set table overflow      ');
  373.                    end
  374.                 end
  375.                end (*case*)
  376.              end;
  377.  
  378.        26 (*chk*): begin typesymbol;
  379.              read(prd,lb,ub);
  380.              if op = 95 then q := lb
  381.              else
  382.              begin
  383.                store[bcp-1].vi := lb; store[bcp].vi := ub;
  384.                q := overs;
  385.                repeat  q := q+2
  386.                until (store[q-1].vi=lb)and (store[q].vi=ub);
  387.                if q=bcp then
  388.                begin  bcp := bcp+2;
  389.                   if bcp=overb then
  390.                 errorl(' boundary table overflow ');
  391.                end
  392.              end
  393.                end;
  394.  
  395.        56 (*lca*): begin
  396.              if mcp + 16 >= overm then
  397.                errorl(' multiple table overflow ');
  398.              mcp := mcp+16;
  399.              q := mcp;
  400.              for i := 0 to 15 (*stringlgth*) do
  401.              begin read(prd,ch);
  402.                store[q+i].vc := ch
  403.              end;
  404.                end;
  405.  
  406.       6 (*sto*): typesymbol;
  407.  
  408.       27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,
  409.       48,49,50,51,52,53,54,58:  ;
  410.  
  411.       (*ord,chr*)
  412.       59,60: goto 1;
  413.  
  414.       61 (*ujc*): ; (*must have same length as ujp*)
  415.  
  416.       end; (*case*)
  417.  
  418.       (* store instruction *)
  419.       with code[pc div 2] do
  420.      if odd(pc) then
  421.      begin  op2 := op; p2 := p; q2 := q
  422.      end  else
  423.      begin  op1 := op; p1 := p; q1 := q
  424.      end;
  425.       pc := pc+1;
  426.       1: readln(prd);
  427.    end; (*assemble*)
  428.  
  429. begin (*load*)
  430.    init;
  431.    generate;
  432.    pc := 0;
  433.    generate;
  434. end; (*load*)
  435.  
  436. (*------------------------------------------------------------------------*)
  437.  
  438. procedure pmd;
  439.    var s :integer; i: integer;
  440.  
  441.    procedure pt;
  442.    begin  write(s:6);
  443.       if abs(store[s].vi) < maxint then write(store[s].vi)
  444.       else write('too big ');
  445.       s := s - 1;
  446.       i := i + 1;
  447.       if i = 4 then
  448.      begin writeln(output); i := 0 end;
  449.    end; (*pt*)
  450.  
  451. begin
  452.    write(' pc =',pc-1:5,' op =',op:3,'  sp =',sp:5,'  mp =',mp:5,
  453.     '  np =',np:5);
  454.    writeln; writeln('--------------------------------------');
  455.  
  456.    s := sp; i := 0;
  457.    while s>=0 do pt;
  458.    s := maxstk;
  459.    while s>=np do pt;
  460. end; (*pmd*)
  461.  
  462. procedure errori(string: beta);
  463. begin writeln; writeln(string);
  464.       pmd; goto 1
  465. end;(*errori*)
  466.  
  467. function base(ld :integer):address;
  468.    var ad :address;
  469. begin  ad := mp;
  470.    while ld>0 do
  471.    begin  ad := store[ad+1].vm;  ld := ld-1
  472.    end;
  473.    base := ad
  474. end; (*base*)
  475.  
  476. procedure compare;
  477. (*comparing is only correct if result by comparing integers will be*)
  478. begin
  479.   i1 := store[sp].va;
  480.   i2 := store[sp+1].va;
  481.   i := 0; b := true;
  482.   while b and (i<>q) do
  483.     if store[i1+i].vi = store[i2+i].vi then i := i+1
  484.     else b := false
  485. end; (*compare*)
  486.  
  487. procedure callsp;
  488.    var line: boolean; adptr,adelnt: address;
  489.        i: integer;
  490.  
  491.    procedure readi(var f:text);
  492.       var ad: address;
  493.    begin ad:= store[sp-1].va;
  494.      read(f,store[ad].vi);
  495.      store[store[sp].va].vc := f^;
  496.      sp:= sp-2
  497.    end;(*readi*)
  498.  
  499.    procedure readr(var f: text);
  500.       var ad: address;
  501.    begin ad:= store[sp-1].va;
  502.      read(f,store[ad].vr);
  503.      store[store[sp].va].vc := f^;
  504.      sp:= sp-2
  505.    end;(*readr*)
  506.  
  507.    procedure readc(var f: text);
  508.       var c: char; ad: address;
  509.    begin read(f,c);
  510.      ad:= store[sp-1].va;
  511.      store[ad].vc := c;
  512.      store[store[sp].va].vc := f^;
  513.      store[store[sp].va].vi := ord(f^);
  514.      sp:= sp-2
  515.    end;(*readc*)
  516.  
  517.    procedure writestr(var f: text);
  518.       var i,j,k: integer;
  519.       ad: address;
  520.    begin ad:= store[sp-3].va;
  521.      k := store[sp-2].vi; j := store[sp-1].vi;
  522.      (* j and k are numbers of characters *)
  523.      if k>j then for i:=1 to k-j do write(f,' ')
  524.         else j:= k;
  525.      for i := 0 to j-1 do write(f,store[ad+i].vc);
  526.      sp:= sp-4
  527.    end;(*writestr*)
  528.  
  529.    procedure getfile(var f: text);
  530.       var ad: address;
  531.    begin ad:=store[sp].va;
  532.      get(f); store[ad].vc := f^;
  533.      sp:=sp-1
  534.    end;(*getfile*)
  535.  
  536.    procedure putfile(var f: text);
  537.       var ad: address;
  538.    begin ad:= store[sp].va;
  539.      f^:= store[ad].vc; put(f);
  540.      sp:= sp-1;
  541.    end;(*putfile*)
  542.  
  543. begin (*callsp*)
  544.       case q of
  545.        0 (*get*): case store[sp].va of
  546.                5: getfile(input);
  547.                6: errori(' get on output file      ');
  548.                7: getfile(prd);
  549.                8: errori(' get on prr file     ')
  550.               end;
  551.        1 (*put*): case store[sp].va of
  552.                5: errori(' put on read file    ');
  553.                6: putfile(output);
  554.                7: errori(' put on prd file     ');
  555.                8: putfile(prr)
  556.               end;
  557.        2 (*rst*): begin
  558.             (*for testphase*)
  559.             np := store[sp].va; sp := sp-1
  560.               end;
  561.        3 (*rln*): begin case store[sp].va of
  562.                  5: begin readln(input);
  563.                       store[inputadr].vc := input^
  564.                     end;
  565.                  6: errori(' readln on output file   ');
  566.                  7: begin readln(input);
  567.                       store[inputadr].vc := input^
  568.                     end;
  569.                  8: errori(' readln on prr file      ')
  570.                 end;
  571.                 sp:= sp-1
  572.               end;
  573.        4 (*new*): begin ad:= np-store[sp].va;
  574.               (*top of stack gives the length in units of storage *)
  575.                 if ad <= ep then
  576.                   errori(' store overflow      ');
  577.                 np:= ad; ad:= store[sp-1].va;
  578.                 store[ad].va := np;
  579.                 sp:=sp-2
  580.               end;
  581.        5 (*wln*): begin case store[sp].va of
  582.                  5: errori(' writeln on input file   ');
  583.                  6: writeln(output);
  584.                  7: errori(' writeln on prd file     ');
  585.                  8: writeln(prr)
  586.                 end;
  587.                 sp:= sp-1
  588.               end;
  589.        6 (*wrs*): case store[sp].va of
  590.                5: errori(' write on input file     ');
  591.                6: writestr(output);
  592.                7: errori(' write on prd file       ');
  593.                8: writestr(prr)
  594.               end;
  595.        7 (*eln*): begin case store[sp].va of
  596.                  5: line:= eoln(input);
  597.                  6: errori(' eoln output file    ');
  598.                  7: line:=eoln(prd);
  599.                  8: errori(' eoln on prr file    ')
  600.                 end;
  601.                 store[sp].vb := line
  602.               end;
  603.        8 (*wri*): begin case store[sp].va of
  604.                  5: errori(' write on input file     ');
  605.                  6: write(output,
  606.                       store[sp-2].vi: store[sp-1].vi);
  607.                  7: errori(' write on prd file       ');
  608.                  8: write(prr,
  609.                       store[sp-2].vi: store[sp-1].vi)
  610.                 end;
  611.                 sp:=sp-3
  612.               end;
  613.        9 (*wrr*): begin case store[sp].va of
  614.                  5: errori(' write on input file     ');
  615.                  6: write(output,
  616.                       store[sp-2].vr: store[sp-1].vi);
  617.                  7: errori(' write on prd file       ');
  618.                  8: write(prr,
  619.                       store[sp-2].vr: store[sp-1].vi)
  620.                 end;
  621.                 sp:=sp-3
  622.               end;
  623.        10(*wrc*): begin case store[sp].va of
  624.                  5: errori(' write on input file     ');
  625.                  6: write(output,store[sp-2].vc:
  626.                       store[sp-1].vi);
  627.                  7: errori(' write on prd file       ');
  628.                  8: write(prr,chr(store[sp-2].vi):
  629.                       store[sp-1].vi);
  630.                 end;
  631.                 sp:=sp-3
  632.               end;
  633.        11(*rdi*): case store[sp].va of
  634.                5: readi(input);
  635.                6: errori(' read on output file     ');
  636.                7: readi(prd);
  637.                8: errori(' read on prr file    ')
  638.               end;
  639.        12(*rdr*): case store[sp].va of
  640.                5: readr(input);
  641.                6: errori(' read on output file     ');
  642.                7: readr(prd);
  643.                8: errori(' read on prr file    ')
  644.               end;
  645.        13(*rdc*): case store[sp].va of
  646.                5: readc(input);
  647.                6: errori(' read on output file     ');
  648.                7: readc(prd);
  649.                8: errori(' read on prr file    ')
  650.               end;
  651.        14(*sin*): store[sp].vr:= sin(store[sp].vr);
  652.        15(*cos*): store[sp].vr:= cos(store[sp].vr);
  653.        16(*exp*): store[sp].vr:= exp(store[sp].vr);
  654.        17(*log*): store[sp].vr:= ln(store[sp].vr);
  655.        18(*sqt*): store[sp].vr:= sqrt(store[sp].vr);
  656.        19(*atn*): store[sp].vr:= arctan(store[sp].vr);
  657.        20(*sav*): begin ad:=store[sp].va;
  658.              store[ad].va := np;
  659.              sp:= sp-1
  660.               end;
  661.       end;(*case q*)
  662. end;(*callsp*)
  663.  
  664. begin (* main *)
  665.   rewrite(prr);
  666.   load; (* assembles and stores code *)
  667.   (* writeln(output); for testing *)
  668.   pc := 0; sp := -1; mp := 0; np := maxstk+1; ep := 5;
  669.   store[inputadr].vc := input^;
  670.   store[prdadr].vc := prd^;
  671.   interpreting := true;
  672.  
  673.   while interpreting do
  674.   begin
  675.     (*fetch*)
  676.     with code[pc div 2] do
  677.       if odd(pc) then
  678.       begin op := op2; p := p2; q := q2
  679.       end else
  680.       begin op := op1; p := p1; q := q1
  681.       end;
  682.     pc := pc+1;
  683.  
  684.     (*execute*)
  685.     case op of
  686.  
  687.       105,106,107,108,109,
  688.       0 (*lod*): begin  ad := base(p) + q;
  689.               sp := sp+1;
  690.               store[sp] := store[ad]
  691.              end;
  692.  
  693.       65,66,67,68,69,
  694.       1 (*ldo*): begin
  695.               sp := sp+1;
  696.               store[sp] := store[q]
  697.              end;
  698.  
  699.       70,71,72,73,74,
  700.       2 (*str*): begin  store[base(p)+q] := store[sp];
  701.               sp := sp-1
  702.              end;
  703.  
  704.       75,76,77,78,79,
  705.       3 (*sro*): begin  store[q] := store[sp];
  706.               sp := sp-1
  707.              end;
  708.  
  709.       4 (*lda*): begin sp := sp+1;
  710.               store[sp].va := base(p) + q
  711.              end;
  712.  
  713.       5 (*lao*): begin sp := sp+1;
  714.               store[sp].va := q
  715.              end;
  716.  
  717.       80,81,82,83,84,
  718.       6 (*sto*): begin
  719.               store[store[sp-1].va] := store[sp];
  720.               sp := sp-2;
  721.              end;
  722.  
  723.       7 (*ldc*): begin sp := sp+1;
  724.               if p=1 then
  725.               begin store[sp].vi := q;
  726.               end else
  727.               if p = 6 then store[sp].vc := chr(q)
  728.               else
  729.                 if p = 3 then store[sp].vb := q = 1
  730.                 else (* load nil *) store[sp].va := maxstr
  731.              end;
  732.  
  733.       8 (*lci*): begin sp := sp+1;
  734.               store[sp] := store[q]
  735.              end;
  736.  
  737.       85,86,87,88,89,
  738.       9 (*ind*): begin ad := store[sp].va + q;
  739.               (* q is a number of storage units *)
  740.               store[sp] := store[ad]
  741.              end;
  742.  
  743.       90,91,92,93,94,
  744.       10 (*inc*): store[sp].vi := store[sp].vi+q;
  745.  
  746.       11 (*mst*): begin (*p=level of calling procedure minus level of called
  747.                   procedure + 1;  set dl and sl, increment sp*)
  748.                (* then length of this element is
  749.               max(intsize,realsize,boolsize,charsize,ptrsize *)
  750.                store[sp+2].vm := base(p);
  751.                (* the length of this element is ptrsize *)
  752.                store[sp+3].vm := mp;
  753.                (* idem *)
  754.                store[sp+4].vm := ep;
  755.                (* idem *)
  756.                sp := sp+5
  757.               end;
  758.  
  759.       12 (*cup*): begin (*p=no of locations for parameters, q=entry point*)
  760.                mp := sp-(p+4);
  761.                store[mp+4].vm := pc;
  762.                pc := q
  763.               end;
  764.  
  765.       13 (*ent*): if p = 1 then
  766.             begin sp := mp + q; (*q = length of dataseg*)
  767.               if sp > np then errori(' store overflow      ');
  768.             end
  769.               else
  770.             begin ep := sp+q;
  771.               if ep > np then errori(' store overflow      ');
  772.             end;
  773.             (*q = max space required on stack*)
  774.  
  775.       14 (*ret*): begin case p of
  776.                  0: sp:= mp-1;
  777.                  1,2,3,4,5: sp:= mp
  778.                 end;
  779.                 pc := store[mp+4].vm;
  780.                 ep := store[mp+3].vm;
  781.                 mp:= store[mp+2].vm;
  782.               end;
  783.  
  784.       15 (*csp*): callsp;
  785.  
  786.       16 (*ixa*): begin
  787.                i := store[sp].vi;
  788.                sp := sp-1;
  789.                store[sp].va := q*i+store[sp].va;
  790.               end;
  791.  
  792.       17 (*equ*): begin  sp := sp-1;
  793.                case p of
  794.              1: store[sp].vb := store[sp].vi = store[sp+1].vi;
  795.              0: store[sp].vb := store[sp].va = store[sp+1].va;
  796.              6: store[sp].vb := store[sp].vc = store[sp+1].vc;
  797.              2: store[sp].vb := store[sp].vr = store[sp+1].vr;
  798.              3: store[sp].vb := store[sp].vb = store[sp+1].vb;
  799.              4: store[sp].vb := store[sp].vs = store[sp+1].vs;
  800.              5: begin  compare;
  801.                    store[sp].vb := b;
  802.                 end;
  803.                end; (*case p*)
  804.               end;
  805.  
  806.       18 (*neq*): begin  sp := sp-1;
  807.                case p of
  808.              0: store[sp].vb := store[sp].va <> store[sp+1].va;
  809.              1: store[sp].vb := store[sp].vi <> store[sp+1].vi;
  810.              6: store[sp].vb := store[sp].vc <> store[sp+1].vc;
  811.              2: store[sp].vb := store[sp].vr <> store[sp+1].vr;
  812.              3: store[sp].vb := store[sp].vb <> store[sp+1].vb;
  813.              4: store[sp].vb := store[sp].vs <> store[sp+1].vs;
  814.              5: begin  compare;
  815.                    store[sp].vb := not b;
  816.                 end
  817.                end; (*case p*)
  818.               end;
  819.  
  820.       19 (*geq*): begin  sp := sp-1;
  821.                case p of
  822.              0: errori(' <,<=,>,>= for address   ');
  823.              1: store[sp].vb := store[sp].vi >= store[sp+1].vi;
  824.              6: store[sp].vb := store[sp].vc >= store[sp+1].vc;
  825.              2: store[sp].vb := store[sp].vr >= store[sp+1].vr;
  826.              3: store[sp].vb := store[sp].vb >= store[sp+1].vb;
  827.              4: store[sp].vb := store[sp].vs >= store[sp+1].vs;
  828.              5: begin compare;
  829.                   store[sp].vb := b or
  830.                 (store[i1+i].vi >= store[i2+i].vi)
  831.                 end
  832.                end; (*case p*)
  833.               end;
  834.  
  835.       20 (*grt*): begin  sp := sp-1;
  836.                case p of
  837.              0: errori(' <,<=,>,>= for address   ');
  838.              1: store[sp].vb := store[sp].vi > store[sp+1].vi;
  839.              6: store[sp].vb := store[sp].vc > store[sp+1].vc;
  840.              2: store[sp].vb := store[sp].vr > store[sp+1].vr;
  841.              3: store[sp].vb := store[sp].vb > store[sp+1].vb;
  842.              4: errori(' set inclusion       ');
  843.              5: begin  compare;
  844.                   store[sp].vb := not b and
  845.                 (store[i1+i].vi > store[i2+i].vi)
  846.                 end
  847.                end; (*case p*)
  848.               end;
  849.  
  850.       21 (*leq*): begin  sp := sp-1;
  851.                case p of
  852.              0: errori(' <,<=,>,>= for address   ');
  853.              1: store[sp].vb := store[sp].vi <= store[sp+1].vi;
  854.              6: store[sp].vb := store[sp].vc <= store[sp+1].vc;
  855.              2: store[sp].vb := store[sp].vr <= store[sp+1].vr;
  856.              3: store[sp].vb := store[sp].vb <= store[sp+1].vb;
  857.              4: store[sp].vb := store[sp].vs <= store[sp+1].vs;
  858.              5: begin  compare;
  859.                   store[sp].vb := b or
  860.                 (store[i1+i].vi <= store[i2+i].vi)
  861.                 end;
  862.                end; (*case p*)
  863.               end;
  864.  
  865.       22 (*les*): begin  sp := sp-1;
  866.                case p of
  867.              0: errori(' <,<=,>,>= for address   ');
  868.              1: store[sp].vb := store[sp].vi < store[sp+1].vi;
  869.              6: store[sp].vb := store[sp].vc < store[sp+1].vc;
  870.              2: store[sp].vb := store[sp].vr < store[sp+1].vr;
  871.              3: store[sp].vb := store[sp].vb < store[sp+1].vb;
  872.              5: begin  compare;
  873.                   store[sp].vb := not b and
  874.                 (store[i1+i].vi < store[i2+i].vi)
  875.                 end
  876.                end; (*case p*)
  877.               end;
  878.  
  879.       23 (*ujp*): pc := q;
  880.  
  881.       24 (*fjp*): begin  if not store[sp].vb then pc := q;
  882.                sp := sp-1
  883.               end;
  884.  
  885.       25 (*xjp*): begin
  886.                pc := store[sp].vi + q;
  887.                sp := sp-1
  888.               end;
  889.  
  890.       95 (*chka*): if (store[sp].va < np) or
  891.               (store[sp].va > (maxstr-q)) then
  892.              errori(' bad pointer value       ');
  893.  
  894.       96,97,98,99,
  895.       26 (*chk*): if (store[sp].vi < store[q-1].vi) or
  896.              (store[sp].vi > store[q].vi) then
  897.             errori(' value out of range      ');
  898.  
  899.       27 (*eof*): begin  i := store[sp].vi;
  900.                if i=inputadr then
  901.                begin store[sp].vb := eof(input);
  902.                end else errori(' code in error       ')
  903.               end;
  904.  
  905.       28 (*adi*): begin  sp := sp-1;
  906.                store[sp].vi := store[sp].vi + store[sp+1].vi
  907.               end;
  908.  
  909.       29 (*adr*): begin  sp := sp-1;
  910.                store[sp].vr := store[sp].vr + store[sp+1].vr
  911.               end;
  912.  
  913.       30 (*sbi*): begin sp := sp-1;
  914.                store[sp].vi := store[sp].vi - store[sp+1].vi
  915.               end;
  916.  
  917.       31 (*sbr*): begin  sp := sp-1;
  918.                store[sp].vr := store[sp].vr - store[sp+1].vr
  919.               end;
  920.  
  921.       32 (*sgs*): store[sp].vs := [store[sp].vi];
  922.  
  923.       33 (*flt*): store[sp].vr := store[sp].vi;
  924.  
  925.       34 (*flo*): store[sp-1].vr := store[sp-1].vi;
  926.  
  927.       35 (*trc*): store[sp].vi := trunc(store[sp].vr);
  928.  
  929.       36 (*ngi*): store[sp].vi := -store[sp].vi;
  930.  
  931.       37 (*ngr*): store[sp].vr := -store[sp].vr;
  932.  
  933.       38 (*sqi*): store[sp].vi := sqr(store[sp].vi);
  934.  
  935.       39 (*sqr*): store[sp].vr := sqr(store[sp].vr);
  936.  
  937.       40 (*abi*): store[sp].vi := abs(store[sp].vi);
  938.  
  939.       41 (*abr*): store[sp].vr := abs(store[sp].vr);
  940.  
  941.       42 (*not*): store[sp].vb := not store[sp].vb;
  942.  
  943.       43 (*and*): begin  sp := sp-1;
  944.                store[sp].vb := store[sp].vb and store[sp+1].vb
  945.               end;
  946.  
  947.       44 (*ior*): begin  sp := sp-1;
  948.                store[sp].vb := store[sp].vb or store[sp+1].vb
  949.               end;
  950.  
  951.       45 (*dif*): begin  sp := sp-1;
  952.                store[sp].vs := store[sp].vs - store[sp+1].vs
  953.               end;
  954.  
  955.       46 (*int*): begin  sp := sp-1;
  956.                store[sp].vs := store[sp].vs * store[sp+1].vs
  957.               end;
  958.  
  959.       47 (*uni*): begin  sp := sp-1;
  960.                store[sp].vs := store[sp].vs + store[sp+1].vs
  961.               end;
  962.  
  963.       48 (*inn*): begin
  964.                sp := sp - 1; i := store[sp].vi;
  965.                store[sp].vb := i in store[sp+1].vs;
  966.               end;
  967.  
  968.       49 (*mod*): begin  sp := sp-1;
  969.                store[sp].vi := store[sp].vi mod store[sp+1].vi
  970.               end;
  971.  
  972.       50 (*odd*): store[sp].vb := odd(store[sp].vi);
  973.  
  974.       51 (*mpi*): begin  sp := sp-1;
  975.                store[sp].vi := store[sp].vi * store[sp+1].vi
  976.               end;
  977.  
  978.       52 (*mpr*): begin  sp := sp-1;
  979.                store[sp].vr := store[sp].vr * store[sp+1].vr
  980.               end;
  981.  
  982.       53 (*dvi*): begin  sp := sp-1;
  983.                store[sp].vi := store[sp].vi div store[sp+1].vi
  984.               end;
  985.  
  986.       54 (*dvr*): begin  sp := sp-1;
  987.                store[sp].vr := store[sp].vr / store[sp+1].vr
  988.               end;
  989.  
  990.       55 (*mov*): begin i1 := store[sp-1].va;
  991.                i2 := store[sp].va; sp := sp-2;
  992.                for i := 0 to q-1 do store[i1+i] := store[i2+i]
  993.                (* q is a number of storage units *)
  994.               end;
  995.  
  996.       56 (*lca*): begin  sp := sp+1;
  997.                store[sp].va := q;
  998.               end;
  999.  
  1000.       100,101,102,103,104,
  1001.       57 (*dec*): store[sp].vi := store[sp].vi-q;
  1002.  
  1003.       58 (*stp*): interpreting := false;
  1004.  
  1005.       59 (*ord*): (*only used to change the tagfield*)
  1006.               begin
  1007.               end;
  1008.  
  1009.       60 (*chr*): begin
  1010.               end;
  1011.  
  1012.       61 (*ujc*): errori(' case - error        ');
  1013.     end
  1014.   end; (*while interpreting*)
  1015.  
  1016. 1 :
  1017. end.
  1018.